-version=0.27.0
+version=0.29.0
profile=conventional
break-infix=fit-or-vertical
parse-docstrings=true
+## v6.3.0 (2026-08-20)
+
+- cohttp: `Cohttp.Path.resolve_local_file` no longer escapes the docroot when
+ given percent-encoded traversal sequences such as `..%2f..%2f`. The URI path
+ is percent-decoded exactly once before `.` and `..` segments are removed.
+ (#1145 @avsm and Sapphire Livingstone, review by @mdales @edwintorok @patricoferris)
+
+- cohttp: `Cohttp.Path.resolve_local_file` collapses empty path segments and
+ drops a trailing slash. A request for `/dir//sub/` now resolves to
+ `docroot/dir/sub` instead of `docroot/dir//sub/`. (#1145 @avsm)
+
+- cohttp: Add `Cohttp.Path.normalise`, which converts a request URI into a
+ relative path that cannot ascend above its root. Servers that make access
+ control decisions on path segments must apply it to `Request.uri` before
+ inspecting them, as `Request.uri` does not normalise absolute-form or
+ percent-encoded targets. (#1145 @avsm)
+ ```ocaml
+ let callback _conn req _body =
+ let uri = Cohttp.Request.uri req in
+ match String.split_on_char '/' (Cohttp.Path.normalise uri) with
+ | "admin" :: _ when not (authorised req) -> Server.respond_not_found ()
+ | _ ->
+ let fname = Cohttp.Path.resolve_local_file ~docroot ~uri in
+ Server.respond_file ~fname ()
+ ```
+ Normalisation is not applied by default, as existing code may depend on the
+ present semantics, which are safe when not combined with local file
+ resolution.
+
+- cohttp-mirage: The static file server normalises the request path of every
+ request, including directory requests, before looking it up in the mirage-kv
+ store. Keys are now percent-decoded, so `/my%20file.txt` retrieves the key
+ `my file.txt` rather than `my%20file.txt` (#1145 @avsm, review by @mdales @edwintorok)
+
+- cohttp-mirage: The `request_fn` callback receives the request URI unchanged.
+ A request that falls back to an index page previously received a URI
+ rewritten to that page. (#1145 @avsm)
+
+- cohttp: do not add `Transfer-Encoding`/`Content-Length` framing headers to
+ responses that cannot have a body (1xx, 204 and 304). This fixes WebSocket
+ handshakes. (@mefyl @avsm, #1141)
+
+- http: add `Status.body_allowed`, the response-status counterpart to the
+ existing `Method.body_allowed`, for users constructing responses by hand
+ (#1141)
+
## v6.2.2 (2026-07-26)
- cohttp: remove duplicate occurance of lwt in dune-project (@Alizter, #1138)
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the Async concurrency library"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"dune" {>= "3.8"}
- "ocaml" {>= "4.14" & < "5.3.0"}
+ "ocaml" {>= "4.14"}
"http" {= version}
"cohttp" {= version}
"async_kernel" {>= "v0.17.0"}
body
|> Body.to_pipe
|> Pipe.iter ~f:(fun b ->
- Stdlib.print_string b;
- return ())
+ Stdlib.print_string b;
+ return ())
let _ =
(* enable logging to stdout *)
(* Do a directory listing *)
Sys.ls_dir file_name
>>= Deferred.List.map ~how:`Parallel ~f:(fun f ->
- let file_name = file_name / f in
- try_with (fun () ->
- Unix.stat file_name >>| fun stat ->
- (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f))
- >>| function
- | Ok v -> v
- | Error _ -> (None, 0L, f))
+ let file_name = file_name / f in
+ try_with (fun () ->
+ Unix.stat file_name >>| fun stat ->
+ (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f))
+ >>| function
+ | Ok v -> v
+ | Error _ -> (None, 0L, f))
>>= fun listing ->
html_of_listing uri path
(sort ((Some `Directory, 0L, "..") :: listing))
let canonical_headers =
sorted_headers
|> List.fold ~init:"" ~f:(fun acc (k, v) ->
- acc
- ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v))
+ acc ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v))
in
let signed_headers =
sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";"
let connect_uri ?interrupt ?ssl_config uri =
(match Uri.scheme uri with
- | Some "httpunix" ->
- let host = Uri.host_with_default ~default:"localhost" uri in
- return @@ `Unix_domain_socket host
- | _ -> (
- lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) ->
- return
- @@
- match (Uri.scheme uri, ssl_config) with
- | Some "https", Some config -> `OpenSSL (addr, port, config)
- | Some "https", None ->
- let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in
- `OpenSSL (addr, port, config)
- | _ -> `TCP (addr, port)))
+ | Some "httpunix" ->
+ let host = Uri.host_with_default ~default:"localhost" uri in
+ return @@ `Unix_domain_socket host
+ | _ -> (
+ lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) ->
+ return
+ @@
+ match (Uri.scheme uri, ssl_config) with
+ | Some "https", Some config -> `OpenSSL (addr, port, config)
+ | Some "https", None ->
+ let config =
+ Conduit_async.V2.Ssl.Config.create ~hostname:host ()
+ in
+ `OpenSSL (addr, port, config)
+ | _ -> `TCP (addr, port)))
>>= fun mode ->
Conduit_async.V2.connect ?interrupt mode >>| fun (r, w) ->
(Input_channel.create r, w)
(* Create a request, then make the request. Figure out an appropriate
transfer encoding *)
(match chunked with
- | false ->
- Body.Private.disable_chunked_encoding body >>| fun (body, body_length) ->
- ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri,
- body )
- | true ->
- Deferred.return
- (match Body.is_empty body with
- | `True ->
- (* Don't used chunked encoding with an empty body *)
- ( Cohttp.Request.make_for_client ?headers ~chunked:false
- ~body_length:0L meth uri,
- body )
- | `Unknown | `False ->
- (* Use chunked encoding if there is a body *)
- ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri,
- body )))
+ | false ->
+ Body.Private.disable_chunked_encoding body
+ >>| fun (body, body_length) ->
+ ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri,
+ body )
+ | true ->
+ Deferred.return
+ (match Body.is_empty body with
+ | `True ->
+ (* Don't used chunked encoding with an empty body *)
+ ( Cohttp.Request.make_for_client ?headers ~chunked:false
+ ~body_length:0L meth uri,
+ body )
+ | `Unknown | `False ->
+ (* Use chunked encoding if there is a body *)
+ ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri,
+ body )))
>>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req
let get ?interrupt ?ssl_config ?headers uri =
let results =
tests
|> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) ->
- Logs.debug (fun m -> m "Running %s" name);
- let res =
- try_with test >>| function
- | Ok () -> `Ok
- | Error exn -> `Exn exn
- in
- res >>| fun res -> (name, res))
+ Logs.debug (fun m -> m "Running %s" name);
+ let res =
+ try_with test >>| function Ok () -> `Ok | Error exn -> `Exn exn
+ in
+ res >>| fun res -> (name, res))
in
results >>| fun results ->
let ounit_tests =
results
|> List.map ~f:(fun (name, res) ->
- name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
+ name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
in
name >::: ounit_tests)
responses |> Pipe.to_list >>= fun resps ->
resps
|> Deferred.List.iter ~how:`Sequential ~f:(fun (_resp, body) ->
- let expected_body = body_q |> Queue.dequeue_exn in
- body |> Body.to_string >>| fun body ->
- assert_equal ~printer expected_body body)
+ let expected_body = body_q |> Queue.dequeue_exn in
+ body |> Body.to_string >>| fun body ->
+ assert_equal ~printer expected_body body)
in
let large_chunked_response () =
Client.get ~headers uri >>= fun (resp, body) ->
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Benchmarks binaries for Cohttp"
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Cohttp client using Curl & Async as the backend"
bug-reports: "https://github.com/mirage/ocaml-cohttp/issues"
depends: [
"dune" {>= "3.8"}
- "ocurl" {>= "0.9.2"}
+ "curl" {>= "0.10.0"}
"http" {= version}
"stringext"
"cohttp-curl" {= version}
(fun () -> f ())
()
|> Deferred.map ~f:(function
- | `Bad_fd | `Closed -> assert false
- | `Unsupported -> assert false
- | `Interrupted -> ())
+ | `Bad_fd | `Closed -> assert false
+ | `Unsupported -> assert false
+ | `Interrupted -> ())
|> Deferred.ignore_m
in
don't_wait_for event;
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Cohttp client using Curl & Lwt as the backend"
depends: [
"dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "ocurl" {>= "0.9.2"}
+ "curl" {>= "0.10.0"}
"http" {= version}
"cohttp-curl" {= version}
"stringext"
let unregister t curl =
Curl.get_activesocket curl
|> Option.iter (fun fd ->
- match Hashtbl.find_opt t.by_fd fd with
- | None -> ()
- | Some curls ->
- Hashtbl.replace t.by_fd fd
- (List.filter (fun c -> c = curl) curls));
+ match Hashtbl.find_opt t.by_fd fd with
+ | None -> ()
+ | Some curls ->
+ Hashtbl.replace t.by_fd fd (List.filter (fun c -> c = curl) curls));
Curl.Multi.remove t.mt curl;
Hashtbl.remove t.wakeners curl
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Shared code between the individual cohttp-curl clients"
depends: [
"dune" {>= "3.8"}
"ocaml" {>= "4.08"}
- "ocurl" {>= "0.9.2"}
+ "curl" {>= "0.10.0"}
"http" {= version}
"stringext"
"odoc" {with-doc}
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation with eio backend"
module IO = Io.IO
type body = Body.t
-type conn = IO.conn * Cohttp.Connection.t [@@warning "-3"]
+type conn = IO.conn * Cohttp.Connection.t
type writer = Http.Request.t * IO.oc
type response = writer -> unit
https://www.rfc-editor.org/rfc/rfc2606 *)
let uri = Uri.of_string "http://foo.invalid" in
match Cohttp_eio.Client.get ~sw client uri with
- | exception Failure _
- | exception Eio.Io (Eio.Net.E _, _) ->
+ | (exception Failure _) | (exception Eio.Io (Eio.Net.E _, _)) ->
(* This should fail, since we are not using the proxy *)
()
| unexepcted_resp, _ ->
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler"
(* perform call *)
(match body with
- | None -> Lwt.return xml##(send Js.null)
- | Some body ->
- CLB.to_string body >>= fun body ->
- let bs = binary_string body in
- (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob))
+ | None -> Lwt.return xml##(send Js.null)
+ | Some body ->
+ CLB.to_string body >>= fun body ->
+ let bs = binary_string body in
+ (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob))
(fun () -> failwith "could not coerce to blob")
(fun blob -> Lwt.return (xml##(send_blob blob)))*)
- (*Lwt.return (xml##send (Js.Opt.return bs)) *)
- Lwt.return (xml##send (Js.Opt.return (Obj.magic bs))))
+ (*Lwt.return (xml##send (Js.Opt.return bs)) *)
+ Lwt.return (xml##send (Js.Opt.return (Obj.magic bs))))
>>= fun () ->
Lwt.on_cancel res (fun () -> xml##abort);
(* unwrap the response *)
in
(* perform call *)
(match body with
- | None -> Lwt.return xml##(send Js.null)
- | Some body ->
- CLB.to_string body >|= fun body ->
- let bs = binary_string body in
- xml##(send (Js.Opt.return (Obj.magic bs))))
+ | None -> Lwt.return xml##(send Js.null)
+ | Some body ->
+ CLB.to_string body >|= fun body ->
+ let bs = binary_string body in
+ xml##(send (Js.Opt.return (Obj.magic bs))))
>>= fun _body ->
let body = Bb.construct_body xml in
(* (re-)construct the response *)
custom reporter or use:
{[
- let reporter = Logs_browser.console_reporter () in
- Logs.set_reporter reporter
+ let reporter = Logs_browser.console_reporter () in
+ Logs.set_reporter reporter
]} *)
(** Configuration parameters for the XmlHttpRequest engines *)
let () =
Js.export_all
- (object%js
- method request uri =
- let f () =
- let uri = Uri.of_string (Js.to_string uri) in
- let* response, body = Client.get uri in
- let+ body = Cohttp_lwt.Body.to_string body in
- let status =
- Http.Response.status response |> Cohttp.Code.code_of_status
- in
- Js.array
- [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |]
- in
- promise_of_lwt f
- end)
+ object%js
+ method request uri =
+ let f () =
+ let uri = Uri.of_string (Js.to_string uri) in
+ let* response, body = Client.get uri in
+ let+ body = Cohttp_lwt.Body.to_string body in
+ let status =
+ Http.Response.status response |> Cohttp.Code.code_of_status
+ in
+ Js.array
+ [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |]
+ in
+ promise_of_lwt f
+ end
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Command-line utilities shipped with cohttp-lwt-unix"
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for Unix and Windows using Lwt"
| false ->
ls_dir file_name
>>= Lwt_list.map_s (fun f ->
- let file_name = file_name / f in
- Lwt.try_bind
- (fun () -> Lwt_unix.LargeFile.stat file_name)
- (fun stat ->
- Lwt.return
- ( Some
- (kind_of_unix_kind stat.Unix.LargeFile.st_kind),
- stat.Unix.LargeFile.st_size,
- f ))
- (fun _exn -> Lwt.return (None, 0L, f)))
+ let file_name = file_name / f in
+ Lwt.try_bind
+ (fun () -> Lwt_unix.LargeFile.stat file_name)
+ (fun stat ->
+ Lwt.return
+ ( Some (kind_of_unix_kind stat.Unix.LargeFile.st_kind),
+ stat.Unix.LargeFile.st_size,
+ f ))
+ (fun _exn -> Lwt.return (None, 0L, f)))
>>= fun listing ->
let body = html_of_listing uri path (sort listing) info in
Server.respond_string ~status:`OK ~body ())
getenv_opt "http_proxy";
]
|> List.filter_map (function
- | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v)
- | n -> n) )
+ | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v)
+ | n -> n) )
| v -> (v, None, [])
in
stderr, using coloured output if possible.
{[
- Fmt_tty.setup_std_outputs ();
- Logs.set_level ~all:true (Some level);
- Logs.set_reporter Debug.default_reporter
+ Fmt_tty.setup_std_outputs ();
+ Logs.set_level ~all:true (Some level);
+ Logs.set_reporter Debug.default_reporter
]} *)
val activate_debug : unit -> unit
over the various modules logs names as follows.
{[
- (* Set log level v for all loggers, this does also affect cohttp internal loggers *)
- Logs.set_level ~all:true level;
- (* Disable all cohttp-lwt and cohttp-lwt-unix logs *)
- List.iter (fun src ->
- match Logs.Src.name src with
- | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None
- | _ -> ())
- @@ Logs.Src.list ()
+ (* Set log level v for all loggers, this does also affect cohttp internal loggers *)
+ Logs.set_level ~all:true level;
+ (* Disable all cohttp-lwt and cohttp-lwt-unix logs *)
+ List.iter (fun src ->
+ match Logs.Src.name src with
+ | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None
+ | _ -> ())
+ @@ Logs.Src.list ()
]} *)
To create a simple HTTP server listening on port 8089:
{[
- let run = create (`TCP 8080)
+ let run = create (`TCP 8080)
]}
When provided, the [stop] thread will terminate the server if it ever
let results =
tests
|> Lwt_list.map_s (fun (name, test) ->
- Logs.info (fun f -> f "Running %s" name);
- let res =
- Lwt.try_bind test
- (fun () -> return `Ok)
- (fun exn -> return (`Exn exn))
- in
- res >|= fun res -> (name, res))
+ Logs.info (fun f -> f "Running %s" name);
+ let res =
+ Lwt.try_bind test
+ (fun () -> return `Ok)
+ (fun exn -> return (`Exn exn))
+ in
+ res >|= fun res -> (name, res))
in
results >|= fun results ->
let ounit_tests =
results
|> List.map (fun (name, res) ->
- name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
+ name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x)
in
name >::: ounit_tests)
let uri = Request.uri req in
let path = Uri.path uri in
(match Request.meth req with
- | `PUT ->
- let status = if Hashtbl.mem store path then `Created else `No_content in
- Hashtbl.replace store path body;
- Server.respond_string ~status ~body:"" ()
- | `DELETE ->
- if Hashtbl.mem store path then (
- Hashtbl.remove store path;
- Server.respond_string ~status:`No_content ~body:"" ())
- else Server.respond_not_found ~uri ()
- | `HEAD ->
- if Hashtbl.mem store path then
- Server.respond_string ~body:"" ~status:`OK ()
- else Server.respond_string ~body:"" ~status:`Not_found ()
- | `GET -> (
- match Hashtbl.find_opt store path with
- | Some body -> Server.respond_string ~status:`OK ~body ()
- | None -> Server.respond_not_found ~uri ())
- | meth ->
- Server.respond_string ~status:`Method_not_allowed
- ~body:("Unsupported method " ^ Code.string_of_method meth)
- ())
+ | `PUT ->
+ let status =
+ if Hashtbl.mem store path then `Created else `No_content
+ in
+ Hashtbl.replace store path body;
+ Server.respond_string ~status ~body:"" ()
+ | `DELETE ->
+ if Hashtbl.mem store path then (
+ Hashtbl.remove store path;
+ Server.respond_string ~status:`No_content ~body:"" ())
+ else Server.respond_not_found ~uri ()
+ | `HEAD ->
+ if Hashtbl.mem store path then
+ Server.respond_string ~body:"" ~status:`OK ()
+ else Server.respond_string ~body:"" ~status:`Not_found ()
+ | `GET -> (
+ match Hashtbl.find_opt store path with
+ | Some body -> Server.respond_string ~status:`OK ~body ()
+ | None -> Server.respond_not_found ~uri ())
+ | meth ->
+ Server.respond_string ~status:`Method_not_allowed
+ ~body:("Unsupported method " ^ Code.string_of_method meth)
+ ())
>|= Cohttp_lwt_unix_test.response
in
Cohttp_lwt_unix_test.test_server_s ~name:"mutable resources" spec tests
();
]
@ List.init (leak_repeat * 2) (fun i _ _ ->
- (* no leaks *)
- if i mod 2 = 0 then
- Server.respond_string ~status:`OK ~body:"" () >|= fun rsp ->
- `Response rsp
- else
- Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp ->
- `Response rsp)
+ (* no leaks *)
+ if i mod 2 = 0 then
+ Server.respond_string ~status:`OK ~body:"" () >|= fun rsp ->
+ `Response rsp
+ else
+ Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp ->
+ `Response rsp)
(* pipelined_expert *)
@ [
(fun _ _ ->
Client.get ~ctx uri >>= fun (resp, body) ->
assert_equal (Response.status resp) `Not_modified;
let headers = Response.headers resp in
- assert_equal ~printer:Transfer.string_of_encoding
- Transfer.(Fixed 0L)
+ assert_equal ~printer:Transfer.string_of_encoding Transfer.Unknown
(Header.get_transfer_encoding headers);
body |> Body.is_empty >|= fun is_empty ->
assert_bool "No body returned when not modified" is_empty
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation using the Lwt concurrency library"
(* select encoding based on (1st) header or (2nd) body *)
(match Header.get_transfer_encoding headers with
- | Unknown -> (
- match Body.transfer_encoding body with
- | Fixed _ as e -> Lwt.return (e, body)
- | Chunked as e when connection.persistent = `True ->
- Lwt.return (e, body)
- | Chunked (* connection.persistent <> `True *) ->
- (* We don't know yet whether chunked encoding is supported.
- * Therefore use fixed length encoding. *)
- Body.length body >>= fun (length, body) ->
- Lwt.return (Cohttp.Transfer.Fixed length, body)
- | Unknown -> assert false)
- | e -> Lwt.return (e, body))
+ | Unknown -> (
+ match Body.transfer_encoding body with
+ | Fixed _ as e -> Lwt.return (e, body)
+ | Chunked as e when connection.persistent = `True ->
+ Lwt.return (e, body)
+ | Chunked (* connection.persistent <> `True *) ->
+ (* We don't know yet whether chunked encoding is supported.
+ * Therefore use fixed length encoding. *)
+ Body.length body >>= fun (length, body) ->
+ Lwt.return (Cohttp.Transfer.Fixed length, body)
+ | Unknown -> assert false)
+ | e -> Lwt.return (e, body))
>>= fun (encoding, body) ->
let headers =
if
(fun () ->
res >>= fun (_, body) ->
(match body with
- | `Empty | `String _ | `Strings _ -> Lwt.return_unit
- | `Stream stream -> Lwt_stream.closed stream)
+ | `Empty | `String _ | `Strings _ -> Lwt.return_unit
+ | `Stream stream -> Lwt_stream.closed stream)
>>= fun () ->
Connection.close connection;
Lwt.return_unit)
let call self ?headers ?body ?absolute_form meth uri =
(match self.proxy_endp with
- | None ->
- Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp ->
- self.proxy_endp <- Some proxy_endp;
- Lwt.return proxy_endp
- | Some proxy_endp -> Lwt.return proxy_endp)
+ | None ->
+ Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp ->
+ self.proxy_endp <- Some proxy_endp;
+ Lwt.return proxy_endp
+ | Some proxy_endp -> Lwt.return proxy_endp)
>>= fun proxy_endp ->
let remote_port =
match Uri_services.tcp_port_of_uri uri with
follows in [cohttp-lwt-unix]
{[
- Cohttp_lwt_unix.Debug.activate_debug ();
- Logs.set_level (Some Logs.Warning)
+ Cohttp_lwt_unix.Debug.activate_debug ();
+ Logs.set_level (Some Logs.Warning)
]}
@raise {!Connection.Retry}
open Lwt.Infix
module Header = Cohttp.Header
-module Connection = Cohttp.Connection [@@warning "-3"]
+module Connection = Cohttp.Connection
module Make (IO : S.IO) = struct
module IO = IO
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP implementation for the MirageOS unikernel"
"mirage-channel" {>= "4.0.0"}
"conduit" {>= "8.0.0"}
"conduit-mirage" {>= "8.0.0"}
- "mirage-kv" {>= "3.0.0"}
+ "mirage-kv" {>= "6.0.1"}
"lwt" {>= "2.4.3"}
"cohttp-lwt" {= version}
"cstruct" {>= "6.0.0"}
"fmt" {>= "0.8.7"}
- "astring"
"magic-mime"
"ppx_sexp_conv" {>= "v0.13.0"}
+ "alcotest" {with-test & >= "1.7.0"}
"cohttp" {= version}
"odoc" {with-doc}
]
--- /dev/null
+(executable
+ (name static_server)
+ (modules static_server)
+ (libraries
+ cohttp-mirage
+ cohttp-lwt-unix
+ mirage-kv
+ optint
+ lwt.unix
+ logs.fmt
+ fmt.tty))
--- /dev/null
+open Lwt.Infix
+
+module Dir : sig
+ include Mirage_kv.RO
+
+ val connect : string -> t
+end = struct
+ type t = { root : string }
+ type key = Mirage_kv.Key.t
+ type error = Mirage_kv.error
+
+ let pp_error = Mirage_kv.pp_error
+ let connect root = { root }
+ let disconnect _ = Lwt.return_unit
+
+ let path t key =
+ let segment s =
+ match s with
+ | "" | "." | ".." -> None
+ | s when String.exists (function '/' | '\000' -> true | _ -> false) s ->
+ None
+ | s -> Some s
+ in
+ let rec go acc = function
+ | [] -> Some acc
+ | s :: rest -> (
+ match segment s with
+ | None -> None
+ | Some s -> go (Filename.concat acc s) rest)
+ in
+ go t.root (Mirage_kv.Key.segments key)
+
+ let stat t key =
+ match path t key with
+ | None -> Lwt.return None
+ | Some path ->
+ Lwt.catch
+ (fun () -> Lwt_unix.stat path >|= fun stat -> Some (path, stat))
+ (function
+ | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
+ Lwt.return None
+ | e -> Lwt.reraise e)
+
+ let get t key =
+ stat t key >>= function
+ | Some (path, { Unix.st_kind = Unix.S_REG; _ }) ->
+ Lwt_io.with_file ~mode:Lwt_io.Input path Lwt_io.read >|= Result.ok
+ | Some _ -> Lwt.return (Error (`Value_expected key))
+ | None -> Lwt.return (Error (`Not_found key))
+
+ let exists t key =
+ stat t key >|= function
+ | Some (_, { Unix.st_kind = Unix.S_REG; _ }) -> Ok (Some `Value)
+ | Some (_, { Unix.st_kind = Unix.S_DIR; _ }) -> Ok (Some `Dictionary)
+ | Some _ | None -> Ok None
+
+ let size t key =
+ stat t key >|= function
+ | Some (_, { Unix.st_size = size; _ }) -> Ok (Optint.Int63.of_int size)
+ | None -> Error (`Not_found key)
+
+ let list t key =
+ match path t key with
+ | None -> Lwt.return (Error (`Not_found key))
+ | Some dir ->
+ Lwt.catch
+ (fun () ->
+ Lwt_unix.files_of_directory dir
+ |> Lwt_stream.to_list
+ >>= Lwt_list.filter_map_s (fun name ->
+ if name = "." || name = ".." then Lwt.return_none
+ else
+ Lwt_unix.stat (Filename.concat dir name)
+ >|= fun { Unix.st_kind; _ } ->
+ match st_kind with
+ | Unix.S_REG -> Some (Mirage_kv.Key.add key name, `Value)
+ | Unix.S_DIR -> Some (Mirage_kv.Key.add key name, `Dictionary)
+ | _ -> None)
+ >|= Result.ok)
+ (function
+ | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
+ Lwt.return (Error (`Not_found key))
+ | e -> Lwt.reraise e)
+
+ let get_partial _ key ~offset:_ ~length:_ =
+ Lwt.return (Error (`Not_found key))
+
+ let last_modified _ key = Lwt.return (Error (`Not_found key))
+ let digest _ key = Lwt.return (Error (`Not_found key))
+end
+
+let html_escape s =
+ let b = Buffer.create (String.length s) in
+ String.iter
+ (function
+ | '&' -> Buffer.add_string b "&"
+ | '<' -> Buffer.add_string b "<"
+ | '>' -> Buffer.add_string b ">"
+ | '"' -> Buffer.add_string b """
+ | '\'' -> Buffer.add_string b "'"
+ | c -> Buffer.add_char b c)
+ s;
+ Buffer.contents b
+
+let html_of_listing dir entries =
+ let segments = Mirage_kv.Key.segments dir in
+ let link segments text =
+ let href =
+ segments
+ |> List.map (Uri.pct_encode ~component:`Path)
+ |> String.concat "/"
+ |> html_escape
+ in
+ Printf.sprintf {|<li><a href="/%s">%s</a></li>|} href (html_escape text)
+ in
+ let parent =
+ match List.rev segments with
+ | [] -> []
+ | _ :: up -> [ link (List.rev up) "../" ]
+ in
+ let entry (key, kind) =
+ let name = Mirage_kv.Key.basename key in
+ let text = match kind with `Dictionary -> name ^ "/" | `Value -> name in
+ (name, link (segments @ [ name ]) text)
+ in
+ let entries =
+ List.map entry entries
+ |> List.sort (fun (a, _) (b, _) -> String.compare a b)
+ |> List.map snd
+ in
+ let title = "Index of " ^ html_escape (Mirage_kv.Key.to_string dir) in
+ String.concat "\n"
+ ([
+ "<!DOCTYPE html>";
+ "<html>";
+ "<head><title>" ^ title ^ "</title></head>";
+ "<body>";
+ "<h1>" ^ title ^ "</h1>";
+ "<ul>";
+ ]
+ @ parent
+ @ entries
+ @ [ "</ul>"; "</body>"; "</html>"; "" ])
+
+module Generated_index (KV : Mirage_kv.RO) : Mirage_kv.RO with type t = KV.t =
+struct
+ include KV
+
+ let index = "index.html"
+
+ let generates t key =
+ if Mirage_kv.Key.basename key <> index then Lwt.return_false
+ else
+ KV.exists t (Mirage_kv.Key.parent key) >|= function
+ | Ok (Some `Dictionary) -> true
+ | Ok (Some `Value | None) | Error _ -> false
+
+ let get t key =
+ KV.get t key >>= function
+ | Ok _ as ok -> Lwt.return ok
+ | Error _ as error -> (
+ generates t key >>= function
+ | false -> Lwt.return error
+ | true -> (
+ let dir = Mirage_kv.Key.parent key in
+ KV.list t dir >|= function
+ | Ok entries -> Ok (html_of_listing dir entries)
+ | Error _ -> error))
+
+ let exists t key =
+ KV.exists t key >>= function
+ | Ok None -> (
+ generates t key >|= function
+ | true -> Ok (Some `Value)
+ | false -> Ok None)
+ | r -> Lwt.return r
+end
+
+module Store = Generated_index (Dir)
+module Server = Cohttp_lwt_unix.Server
+module Static = Cohttp_mirage.Static.HTTP (Store) (Server)
+
+let request_fn uri headers =
+ Cohttp.Header.add headers "x-served-by"
+ (Printf.sprintf "cohttp-mirage static (%s)" (Uri.path uri))
+
+let () =
+ let docroot = if Array.length Sys.argv > 1 then Sys.argv.(1) else "htdocs" in
+ let port =
+ if Array.length Sys.argv > 2 then int_of_string Sys.argv.(2) else 8080
+ in
+ Fmt_tty.setup_std_outputs ();
+ Logs.set_level (Some Logs.Info);
+ Logs.set_reporter (Logs_fmt.reporter ());
+ Logs.info (fun f -> f "serving %s on http://0.0.0.0:%d/" docroot port);
+ Lwt_main.run
+ (Static.start ~http_port:port ~request_fn (Dir.connect docroot)
+ (fun (`TCP port) spec -> Server.create ~mode:(`TCP (`Port port)) spec))
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.2.2
+ * cohttp v6.3.0
*)
module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct
mirage-channel
mirage-kv
mirage-flow
- magic-mime
- astring))
+ magic-mime))
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.2.2
+ * cohttp v6.3.0
*)
open Lwt.Infix
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.2.2
+ * cohttp v6.3.0
*)
(** Cohttp IO implementation using Mirage channels. *)
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.2.2
+ * cohttp v6.3.0
*)
module Key = Mirage_kv.Key
-module Connection = Cohttp.Connection [@@warning "-3"]
+module Connection = Cohttp.Connection
module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct
open Lwt.Infix
- open Astring
let failf fmt = Fmt.failwith fmt
| Error e -> Fmt.failwith "exists %a" FS.pp_error e
let dispatcher request_fn =
- let rec fn fs uri =
- match Uri.path uri with
- | ("" | "/") as path ->
- Logs.info (fun f -> f "request for '%s'" path);
- fn fs (Uri.with_path uri "index.html")
- | path when String.is_suffix ~affix:"/" path ->
- Logs.info (fun f -> f "request for '%s'" path);
- fn fs (Uri.with_path uri "index.html")
- | path ->
- Logs.info (fun f -> f "request for '%s'" path);
- Lwt.catch
- (fun () ->
- read_fs fs path >>= fun body ->
- let mime_type = Magic_mime.lookup path in
- let headers = Cohttp.Header.init_with "content-type" mime_type in
- let headers =
- match request_fn with
- | None -> headers
- | Some fn -> fn uri headers
- in
- S.respond_string ~status:`OK ~body ~headers ())
- (fun _exn ->
- let with_index = Fmt.str "%s/index.html" path in
- exists fs with_index >>= function
- | true -> fn fs (Uri.with_path uri with_index)
- | false -> S.respond_not_found ())
+ let respond uri path body =
+ let mime_type = Magic_mime.lookup path in
+ let headers = Cohttp.Header.init_with "content-type" mime_type in
+ let headers =
+ match request_fn with None -> headers | Some fn -> fn uri headers
+ in
+ S.respond_string ~status:`OK ~body ~headers ()
in
- fn
+ fun fs uri ->
+ let path =
+ match Cohttp.Path.normalise uri with "" -> "index.html" | path -> path
+ in
+ Logs.info (fun f -> f "request for %S" path);
+ Lwt.try_bind
+ (fun () -> read_fs fs path)
+ (respond uri path)
+ (fun _exn ->
+ let with_index = path ^ "/index.html" in
+ exists fs with_index >>= function
+ | true -> read_fs fs with_index >>= respond uri with_index
+ | false -> S.respond_not_found ())
let start ~http_port ?request_fn fs http =
let callback (_, cid) request _body =
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
- * cohttp v6.2.2
+ * cohttp v6.3.0
*)
(** Serve static HTTP sites from a Mirage key-value store. *)
--- /dev/null
+(executable
+ (name test_static)
+ (modules test_static)
+ (libraries cohttp-mirage cohttp-lwt cohttp http lwt mirage-kv uri alcotest))
+
+(rule
+ (alias runtest)
+ (package cohttp-mirage)
+ (action
+ (run ./test_static.exe)))
--- /dev/null
+(* Tests for [Cohttp_mirage.Static.HTTP]. *)
+
+let run p =
+ match Lwt.state p with
+ | Lwt.Return v -> v
+ | Lwt.Fail e -> raise e
+ | Lwt.Sleep -> Alcotest.fail "promise did not resolve"
+
+(* An in-memory [Mirage_kv.RO] over a list of (key, contents) pairs. *)
+module Mock_fs : sig
+ include Mirage_kv.RO
+
+ val create : (string * string) list -> t
+end = struct
+ type t = (string * string) list
+ type key = Mirage_kv.Key.t
+ type error = Mirage_kv.error
+
+ let pp_error = Mirage_kv.pp_error
+ let create entries = entries
+ let disconnect _ = Lwt.return_unit
+ let path key = String.concat "/" (Mirage_kv.Key.segments key)
+
+ let is_dictionary t path =
+ let prefix = path ^ "/" in
+ List.exists (fun (k, _) -> String.starts_with ~prefix k) t
+
+ let get t key =
+ let path = path key in
+ match List.assoc_opt path t with
+ | Some contents -> Lwt.return (Ok contents)
+ | None when is_dictionary t path -> Lwt.return (Error (`Value_expected key))
+ | None -> Lwt.return (Error (`Not_found key))
+
+ let exists t key =
+ let path = path key in
+ if List.mem_assoc path t then Lwt.return (Ok (Some `Value))
+ else if is_dictionary t path then Lwt.return (Ok (Some `Dictionary))
+ else Lwt.return (Ok None)
+
+ let unsupported _ = Alcotest.fail "unexpected key-value store operation"
+ let get_partial _ _ ~offset:_ ~length:_ = unsupported ()
+ let list _ _ = unsupported ()
+ let last_modified _ _ = unsupported ()
+ let digest _ _ = unsupported ()
+ let size _ _ = unsupported ()
+end
+
+module Mock_server : sig
+ include Cohttp_lwt.S.Server
+
+ val serve : t -> string -> (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t
+end = struct
+ module IO = struct
+ type 'a t = 'a Lwt.t
+
+ let ( >>= ) = Lwt.bind
+ let return = Lwt.return
+
+ type ic = unit
+ type oc = unit
+ type conn = unit
+ type error = |
+
+ let refill () = Lwt.return `Eof
+ let with_input_buffer () ~f = fst (f "" ~pos:0 ~len:0)
+ let read_line () = Lwt.return None
+ let read () _ = Lwt.return ""
+ let write () _ = Lwt.return_unit
+ let flush () = Lwt.return_unit
+ let catch f = Lwt.map Result.ok (f ())
+ let pp_error _ = function (_ : error) -> .
+ end
+
+ type body = Cohttp_lwt.Body.t
+ type conn = IO.conn * Cohttp.Connection.t [@@warning "-3"]
+ type response = Http.Response.t * body
+
+ type response_action =
+ [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit IO.t)
+ | `Response of response ]
+
+ type t = { handler : conn -> Http.Request.t -> body -> response Lwt.t }
+
+ let make ?conn_closed:_ ~callback () = { handler = callback }
+ let unsupported _ = Alcotest.fail "unexpected server operation"
+ let make_response_action ?conn_closed:_ ~callback:_ () = unsupported ()
+ let make_expert ?conn_closed:_ ~callback:_ () = unsupported ()
+ let callback _ _ _ _ = unsupported ()
+
+ let resolve_local_file ~docroot ~uri =
+ Cohttp.Path.resolve_local_file ~docroot ~uri
+
+ let respond ?(headers = Http.Header.init ()) ~status ~body () =
+ Lwt.return (Http.Response.make ~status ~headers (), body)
+
+ let respond_string ?headers ~status ~body () =
+ respond ?headers ~status ~body:(`String body) ()
+
+ let respond_error ?headers ?(status = `Internal_server_error) ~body () =
+ respond_string ?headers ~status ~body ()
+
+ let respond_redirect ?(headers = Http.Header.init ()) ~uri () =
+ let headers = Http.Header.add headers "location" (Uri.to_string uri) in
+ respond_string ~headers ~status:`Found ~body:"" ()
+
+ let respond_need_auth ?(headers = Http.Header.init ()) ~auth () =
+ let headers = Cohttp.Header.add_authorization_req headers auth in
+ respond_string ~headers ~status:`Unauthorized ~body:"" ()
+
+ let respond_not_found ?uri:_ () =
+ respond_string ~status:`Not_found ~body:"Not found" ()
+
+ let serve t target =
+ let request = Http.Request.make ~meth:`GET target in
+ t.handler ((), (Cohttp.Connection.create () [@warning "-3"])) request `Empty
+end
+
+module Static = Cohttp_mirage.Static.HTTP (Mock_fs) (Mock_server)
+
+let store =
+ Mock_fs.create
+ [
+ ("index.html", "root index");
+ ("foo/index.html", "foo index");
+ ("foo/bar/index.html", "foo/bar index");
+ ("style.css", "css body");
+ ("my file.txt", "spaced");
+ ]
+
+let request ?request_fn target =
+ let t = Static.start ~http_port:8080 ?request_fn store (fun _ t -> t) in
+ let response, body = run (Mock_server.serve t target) in
+ (response, run (Cohttp_lwt.Body.to_string body))
+
+let check_served name ~target ~expected =
+ let response, body = request target in
+ Alcotest.(check int)
+ (name ^ ": status") 200
+ (Http.Status.to_int (Http.Response.status response));
+ Alcotest.(check string) (name ^ ": body") expected body
+
+let check_not_found name ~target =
+ let response, _ = request target in
+ Alcotest.(check int)
+ (name ^ ": status") 404
+ (Http.Status.to_int (Http.Response.status response))
+
+let test_index_pages () =
+ check_served "root" ~target:"/" ~expected:"root index";
+ check_served "directory" ~target:"/foo" ~expected:"foo index";
+ check_served "directory trailing slash" ~target:"/foo/" ~expected:"foo index";
+ check_served "nested directory" ~target:"/foo/bar" ~expected:"foo/bar index";
+ check_served "nested directory trailing slash" ~target:"/foo/bar/"
+ ~expected:"foo/bar index";
+ check_served "empty segments collapsed" ~target:"/foo//bar/"
+ ~expected:"foo/bar index"
+
+let test_files () =
+ check_served "file" ~target:"/style.css" ~expected:"css body";
+ check_not_found "missing file" ~target:"/nope.css";
+ check_not_found "missing directory" ~target:"/nope/"
+
+let test_content_type () =
+ let response, _ = request "/style.css" in
+ Alcotest.(check (option string))
+ "css content-type" (Some "text/css")
+ (Http.Header.get (Http.Response.headers response) "content-type");
+ let response, _ = request "/foo/" in
+ Alcotest.(check (option string))
+ "index content-type is that of the page served, not the directory"
+ (Some "text/html")
+ (Http.Header.get (Http.Response.headers response) "content-type")
+
+let test_traversal_clamped () =
+ check_served "dot-dot" ~target:"/foo/../style.css" ~expected:"css body";
+ check_served "dot-dot above root" ~target:"/../../style.css"
+ ~expected:"css body";
+ check_served "encoded slash" ~target:"/..%2f..%2fstyle.css"
+ ~expected:"css body";
+ check_served "fully encoded" ~target:"/%2e%2e%2f%2e%2e%2fstyle.css"
+ ~expected:"css body";
+ check_served "encoded slash into directory index" ~target:"/foo%2fbar%2f"
+ ~expected:"foo/bar index"
+
+(* Percent-decoding should happens exactly once. *)
+let test_single_decode () =
+ check_served "encoded space" ~target:"/my%20file.txt" ~expected:"spaced";
+ check_not_found "double encoded slash" ~target:"/..%252f..%252fstyle.css";
+ check_not_found "double encoded, fully" ~target:"/%252e%252e%252fstyle.css"
+
+let test_request_fn () =
+ let request_fn uri headers =
+ Http.Header.add headers "x-request-uri" (Uri.path uri)
+ in
+ let response, body = request ~request_fn "/foo/" in
+ Alcotest.(check string) "index still served" "foo index" body;
+ Alcotest.(check (option string))
+ "request_fn sees the request URI" (Some "/foo/")
+ (Http.Header.get (Http.Response.headers response) "x-request-uri")
+
+let () =
+ Alcotest.run "cohttp-mirage static"
+ [
+ ( "paths",
+ [
+ ("index pages", `Quick, test_index_pages);
+ ("files", `Quick, test_files);
+ ("content types", `Quick, test_content_type);
+ ("traversal clamped to root", `Quick, test_traversal_clamped);
+ ("single percent-decode", `Quick, test_single_decode);
+ ("request_fn", `Quick, test_request_fn);
+ ] );
+ ]
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Lightweight Cohttp + Lwt based HTTP server"
let* () =
Http.Header.to_list headers
|> Lwt_list.iter_s (fun (k, v) ->
- let* () = Lwt_io.write t.oc k in
- let* () = Lwt_io.write t.oc ": " in
- let* () = Lwt_io.write t.oc v in
- Lwt_io.write t.oc "\r\n")
+ let* () = Lwt_io.write t.oc k in
+ let* () = Lwt_io.write t.oc ": " in
+ let* () = Lwt_io.write t.oc v in
+ Lwt_io.write t.oc "\r\n")
in
let* () = Lwt_io.write t.oc "\r\n" in
Body.write body t.oc
An example server:
{[
- open Lwt.Syntax
-
- let server_callback ctx =
- Lwt.join
- [
- Cohttp_server_lwt_unix.ontext.discard_body ctx;
- Cohttp_server_lwt_unix.ontext.respond ctx (Http.Response.make ())
- (Cohttp_server_lwt_unix.Body.string "hello world");
- ]
-
- let main () =
- let* _server =
- let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
- let server = Cohttp_server_lwt_unix.create server_callback in
- Lwt_io.establish_server_with_client_address ~backlog:10_000
- listen_address (fun _addr ch ->
- Cohttp_server_lwt_unix.handle_connection server ch)
- in
- let forever, _ = Lwt.wait () in
- forever
-
- let () = ignore (Lwt_main.run (main ()))
+ open Lwt.Syntax
+
+ let server_callback ctx =
+ Lwt.join
+ [
+ Cohttp_server_lwt_unix.ontext.discard_body ctx;
+ Cohttp_server_lwt_unix.ontext.respond ctx (Http.Response.make ())
+ (Cohttp_server_lwt_unix.Body.string "hello world");
+ ]
+
+ let main () =
+ let* _server =
+ let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
+ let server = Cohttp_server_lwt_unix.create server_callback in
+ Lwt_io.establish_server_with_client_address ~backlog:10_000
+ listen_address (fun _addr ch ->
+ Cohttp_server_lwt_unix.handle_connection server ch)
+ in
+ let forever, _ = Lwt.wait () in
+ forever
+
+ let () = ignore (Lwt_main.run (main ()))
]} *)
module Body : sig
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "CoHTTP toplevel pretty printers for HTTP types"
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "An OCaml library for HTTP clients and servers"
module Auth = Auth
module Body = Body
module Conf = Conf
-module Connection = Connection [@@deprecated "Connection.t values are useless."]
+module Connection = Connection
module Code = Code
module Cookie = Cookie
module Header = Header
-let resolve_local_file ~docroot ~uri =
- let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in
- let rel_path =
- if String.length path > 0 then String.sub path 1 (String.length path - 1)
- else ""
+let remove_dot_segments path =
+ let rec go acc = function
+ | [] -> List.rev acc
+ | ("" | ".") :: rest -> go acc rest
+ | ".." :: rest -> (
+ match acc with [] -> go [] rest | _ :: tl -> go tl rest)
+ | seg :: rest -> go (seg :: acc) rest
in
- Filename.concat docroot rel_path
+ path |> String.split_on_char '/' |> go [] |> String.concat "/"
+
+let normalise uri = uri |> Uri.path |> Uri.pct_decode |> remove_dot_segments
+let resolve_local_file ~docroot ~uri = Filename.concat docroot (normalise uri)
val resolve_local_file : docroot:string -> uri:Uri.t -> string
(** Resolve the given URI to a local file in the given docroot.
- This decodes and normalises the Uri. It strips out .. characters so that the
- request will not escape the docroot. The returned filepath is fully
- qualified iff the given docroot is fully qualified. *)
+ This is [Filename.concat docroot (normalise uri)]. It decodes
+ percent-encoding once and removes [..] segments so that the request cannot
+ escape the docroot. The returned filepath is fully qualified iff the given
+ docroot is fully qualified. *)
+
+val normalise : Uri.t -> string
+(** [normalise uri] returns the path of [uri] with percent-encoding decoded
+ exactly once and [.]/[..] segments resolved, as a relative path that can
+ never ascend above its root.
+
+ Use this to derive a lookup key from a request URI, for example a filesystem
+ path or a key-value store key. *)
no_proxy
|> String.split_on_char ','
|> List.filter_map (fun pattern ->
- if pattern = "" then None else Some (String.trim pattern))
+ if pattern = "" then None else Some (String.trim pattern))
|> List.map (fun pattern ->
- match Ipaddr.of_string pattern with
- | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr)
- | Error _ -> (
- match Ipaddr.Prefix.of_string pattern with
- | Ok prefix -> Ipaddr_prefix prefix
- | Error _ -> Name (trim_dots ~first_leading:true pattern)
- ))
+ match Ipaddr.of_string pattern with
+ | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr)
+ | Error _ -> (
+ match Ipaddr.Prefix.of_string pattern with
+ | Ok prefix -> Ipaddr_prefix prefix
+ | Error _ -> Name (trim_dots ~first_leading:true pattern)))
in
Patterns patterns
let make ?(version = `HTTP_1_1) ?(status = `OK) ?(encoding = Transfer.Unknown)
?(headers = Header.init ()) () =
let headers =
- match encoding with
- | Unknown -> (
- match Header.get_transfer_encoding headers with
- | Unknown -> Header.add_transfer_encoding headers Chunked
- | _ -> headers)
- | _ -> Header.add_transfer_encoding headers encoding
+ if not (Http.Status.body_allowed status) then headers
+ else
+ match encoding with
+ | Unknown -> (
+ match Header.get_transfer_encoding headers with
+ | Unknown -> Header.add_transfer_encoding headers Chunked
+ | _ -> headers)
+ | _ -> Header.add_transfer_encoding headers encoding
in
{ headers; version; status }
let pp_hum ppf r =
Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum)
-let allowed_body response =
- (* rfc7230#section-5.7.1 *)
- match status response with
- | #Code.informational_status | `No_content | `Not_modified -> false
- | #Code.status_code -> true
+let allowed_body response = Http.Status.body_allowed (status response)
let has_body response =
if allowed_body response then Transfer.has_body (encoding response) else `No
module IO : S.IO
type body
- type conn = IO.conn * Connection.t [@@warning "-3"]
+ type conn = IO.conn * Connection.t
type response
type response_action =
(package cohttp)
(action
(run ./test_proxy.exe)))
+
+(executable
+ (name test_response)
+ (modules test_response)
+ (forbidden_libraries base)
+ (libraries cohttp alcotest))
+
+(rule
+ (alias runtest)
+ (package cohttp)
+ (action
+ (run ./test_response.exe)))
("cwd-docroot cwd", ".", "./buzz", "./buzz");
("cwd-docroot blank-path", ".", "https://example.com", "./");
("cwd-docroot blank-uri", ".", "", "./");
+ ( "percent-encoded slash grandparent blocked",
+ "/foo/bar/baz",
+ "..%2f..%2fbuzz",
+ "/foo/bar/baz/buzz" );
+ ( "fully percent-encoded grandparent blocked",
+ "/foo/bar/baz",
+ "%2e%2e%2f%2e%2e%2fbuzz",
+ "/foo/bar/baz/buzz" );
+ ( "double percent-encoded grandparent blocked",
+ "/foo/bar/baz",
+ "..%252f..%252fbuzz",
+ "/foo/bar/baz/..%2f..%2fbuzz" );
+ ( "double fully percent-encoded grandparent blocked",
+ "/foo/bar/baz",
+ "%252e%252e%252f%252e%252e%252fbuzz",
+ "/foo/bar/baz/%2e%2e%2f%2e%2e%2fbuzz" );
+ ( "triply percent-encoded grandparent blocked",
+ "/foo/bar/baz",
+ "..%25252f..%25252fbuzz",
+ "/foo/bar/baz/..%252f..%252fbuzz" );
+ ( "encoded space preserved",
+ "/foo/bar/baz",
+ "/my%20file.txt",
+ "/foo/bar/baz/my file.txt" );
+ ( "encoded utf8 preserved",
+ "/foo/bar/baz",
+ "/caf%C3%A9.txt",
+ "/foo/bar/baz/caf\xc3\xa9.txt" );
+ ( "encoded NUL preserved",
+ "/foo/bar/baz",
+ "/secret%00.txt",
+ "/foo/bar/baz/secret\x00.txt" );
+ ( "encoded newline preserved",
+ "/foo/bar/baz",
+ "/a%0ab.txt",
+ "/foo/bar/baz/a\nb.txt" );
+ ( "encoded DEL preserved",
+ "/foo/bar/baz",
+ "/a%7fb.txt",
+ "/foo/bar/baz/a\x7fb.txt" );
+ ( "encoded control does not collapse onto plain name",
+ "/foo/bar/baz",
+ "/sol%001.html",
+ "/foo/bar/baz/sol\x001.html" );
]
in
List.iter
(Cohttp.Path.resolve_local_file ~docroot ~uri:(Uri.of_string uri)))
tests
+let test_normalise () =
+ let tests =
+ [
+ ("relative simple", "/foo/bar", "foo/bar");
+ ("relative dot", "/foo/./bar", "foo/bar");
+ ("relative grandparent blocked", "/../../etc/passwd", "etc/passwd");
+ ("encoded slash traversal blocked", "/..%2f..%2fetc/passwd", "etc/passwd");
+ ( "absolute-form grandparent blocked",
+ "http://host/../../etc/passwd",
+ "etc/passwd" );
+ ( "absolute-form deep grandparent blocked",
+ "https://example.com/a/../../../../etc/shadow",
+ "etc/shadow" );
+ ("root path empty", "/", "");
+ ("empty path", "", "");
+ ("trailing slash dropped", "/foo/bar/", "foo/bar");
+ ("encoded trailing slash dropped", "/foo/bar%2f", "foo/bar");
+ ("empty segments collapsed", "/foo//bar", "foo/bar");
+ ("encoded control preserved", "/sol%001.html", "sol\x001.html");
+ ("plain slash separator", "/private/secret.txt", "private/secret.txt");
+ ( "backslash preserved, distinct from slash",
+ "/private%5csecret.txt",
+ "private\\secret.txt" );
+ ( "encoded backslash traversal preserved verbatim",
+ "/..%5c..%5cwindows",
+ "..\\..\\windows" );
+ ]
+ in
+ List.iter
+ (fun (name, uri, expected) ->
+ Alcotest.(check string)
+ name expected
+ (Cohttp.Path.normalise (Uri.of_string uri)))
+ tests
+
let () = Printexc.record_backtrace true
let () =
Alcotest.run "test_path"
[
- ("Path", [ ("Check resolve_local_file", `Quick, test_resolve_local_file) ]);
+ ( "Path",
+ [
+ ("Check resolve_local_file", `Quick, test_resolve_local_file);
+ ("Check normalise", `Quick, test_normalise);
+ ] );
]
--- /dev/null
+open Cohttp
+module String_io = Cohttp.Private.String_io
+module Response_io = Response.Private.Make (String_io.M)
+
+let t_encoding =
+ Alcotest.testable
+ (fun fmt e -> Format.pp_print_string fmt (Transfer.string_of_encoding e))
+ ( = )
+
+let check_encoding name expected response =
+ Alcotest.check t_encoding name expected (Response.encoding response)
+
+let check_no_framing_headers name response =
+ let headers = Response.headers response in
+ Alcotest.(check (option string))
+ (name ^ ": no transfer-encoding header")
+ None
+ (Header.get headers "transfer-encoding");
+ Alcotest.(check (option string))
+ (name ^ ": no content-length header")
+ None
+ (Header.get headers "content-length")
+
+let bodyless_statuses =
+ [
+ `Continue;
+ `Switching_protocols;
+ `Processing;
+ `Checkpoint;
+ `No_content;
+ `Not_modified;
+ `Code 199;
+ ]
+
+let iter_bodyless f =
+ List.iter
+ (fun status -> f (Code.string_of_status status) status)
+ bodyless_statuses
+
+let default_encoding_is_chunked () =
+ check_encoding "unspecified encoding defaults to chunked" Transfer.Chunked
+ (Response.make ())
+
+let explicit_encoding_is_used () =
+ check_encoding "explicit encoding is used" (Transfer.Fixed 5L)
+ (Response.make ~status:`OK ~encoding:(Transfer.Fixed 5L) ())
+
+let encoding_from_headers () =
+ check_encoding "encoding taken from supplied headers" (Transfer.Fixed 42L)
+ (Response.make ~status:`OK
+ ~headers:(Header.of_list [ ("content-length", "42") ])
+ ())
+
+let bodyless_has_no_encoding () =
+ iter_bodyless (fun name status ->
+ let r = Response.make ~status () in
+ check_encoding (name ^ " is not chunked by default") Transfer.Unknown r;
+ check_no_framing_headers name r)
+
+let bodyless_ignores_explicit_encoding () =
+ iter_bodyless (fun name status ->
+ let chunked = Response.make ~status ~encoding:Transfer.Chunked () in
+ check_encoding
+ (name ^ " drops an explicit chunked encoding")
+ Transfer.Unknown chunked;
+ check_no_framing_headers (name ^ " (chunked)") chunked;
+ let fixed = Response.make ~status ~encoding:(Transfer.Fixed 0L) () in
+ check_encoding
+ (name ^ " drops an explicit fixed encoding")
+ Transfer.Unknown fixed;
+ check_no_framing_headers (name ^ " (fixed)") fixed)
+
+let t_has_body =
+ Alcotest.testable
+ (fun fmt -> function
+ | `No -> Format.pp_print_string fmt "`No"
+ | `Unknown -> Format.pp_print_string fmt "`Unknown"
+ | `Yes -> Format.pp_print_string fmt "`Yes")
+ ( = )
+
+let bodyless_has_no_body () =
+ iter_bodyless (fun name status ->
+ Alcotest.check t_has_body (name ^ " has no body") `No
+ (Response.has_body (Response.make ~status ())))
+
+let write_response r =
+ let buf = Buffer.create 128 in
+ Response_io.write ~flush:false (fun _ -> ()) r buf;
+ Buffer.contents buf
+
+let write_chunked_response () =
+ Alcotest.(check string)
+ "a 200 response is framed as chunked"
+ "HTTP/1.1 200 OK\r\ntransfer-encoding: chunked\r\n\r\n0\r\n\r\n"
+ (write_response (Response.make ()))
+
+let write_switching_protocols () =
+ let r =
+ Response.make ~status:`Switching_protocols
+ ~headers:
+ (Header.of_list [ ("upgrade", "websocket"); ("connection", "Upgrade") ])
+ ()
+ in
+ Alcotest.(check string)
+ "a 101 response is written without any framing"
+ "HTTP/1.1 101 Switching Protocols\r\n\
+ upgrade: websocket\r\n\
+ connection: Upgrade\r\n\
+ \r\n"
+ (write_response r)
+
+let write_no_content () =
+ Alcotest.(check string)
+ "a 204 response is written without any framing"
+ "HTTP/1.1 204 No Content\r\n\r\n"
+ (write_response (Response.make ~status:`No_content ()))
+
+let write_not_modified () =
+ Alcotest.(check string)
+ "a 304 response is written without any framing"
+ "HTTP/1.1 304 Not Modified\r\n\r\n"
+ (write_response (Response.make ~status:`Not_modified ()))
+
+let () =
+ Alcotest.run "test_response"
+ [
+ ( "Encoding",
+ [
+ ("default is chunked", `Quick, default_encoding_is_chunked);
+ ("explicit encoding", `Quick, explicit_encoding_is_used);
+ ("from headers", `Quick, encoding_from_headers);
+ ] );
+ ( "Bodyless statuses",
+ [
+ ("no encoding by default", `Quick, bodyless_has_no_encoding);
+ ( "explicit encoding ignored",
+ `Quick,
+ bodyless_ignores_explicit_encoding );
+ ("no body", `Quick, bodyless_has_no_body);
+ ] );
+ ( "Serialization",
+ [
+ ("chunked", `Quick, write_chunked_response);
+ ("101 Switching Protocols", `Quick, write_switching_protocols);
+ ("204 No Content", `Quick, write_no_content);
+ ("304 Not Modified", `Quick, write_not_modified);
+ ] );
+ ]
(lang dune 3.8)
(name cohttp)
-(version v6.2.2)
+(version v6.3.0)
(license ISC)
"An implementation of an HTTP client and server using the Async\nconcurrency library. See the `Cohttp_async` module for information\non how to use this. The package also installs `cohttp-curl-async`\nand a `cohttp-server-async` binaries for quick uses of a HTTP(S)\nclient and server respectively.\n")
(depends
(ocaml
- (and (>= 4.14) (< 5.3.0)))
+ (>= 4.14))
(http
(= :version))
(cohttp
(conduit-mirage
(>= 8.0.0))
(mirage-kv
- (>= 3.0.0))
+ (>= 6.0.1))
(lwt
(>= 2.4.3))
(cohttp-lwt
(>= 6.0.0))
(fmt
(>= 0.8.7))
- astring
magic-mime
(ppx_sexp_conv
(>= v0.13.0))
+ (alcotest
+ (and
+ :with-test
+ (>= 1.7.0)))
(cohttp
(= :version))))
(depends
(ocaml
(>= 4.08))
- (ocurl (>= 0.9.2))
+ (curl (>= 0.10.0))
(http
(= :version))
stringext))
(depends
(ocaml
(>= 4.08))
- (ocurl (>= 0.9.2))
+ (curl (>= 0.10.0))
(http
(= :version))
(cohttp-curl
(description
"An HTTP client that relies on Curl + Async for the backend. Does not require\nconduit for SSL.")
(depends
- (ocurl (>= 0.9.2))
+ (curl (>= 0.10.0))
(http
(= :version))
stringext
};
cohttp-mirage = pkg {
pname = "cohttp-mirage";
+ checkInputs = [ alcotest ];
propagatedBuildInputs = [
mirage-flow mirage-channel conduit conduit-mirage
- mirage-kv lwt cohttp-lwt cstruct fmt astring magic-mime ppx_sexp_conv
+ mirage-kv lwt cohttp-lwt cstruct fmt magic-mime ppx_sexp_conv
];
};
cohttp-bench = pkg {
-version: "6.2.2"
+version: "6.3.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Type definitions of HTTP essentials"
let b = Buffer.create 128 in
to_list h
|> List.iter (fun (k, v) ->
- Buffer.add_string b k;
- Buffer.add_string b ": ";
- Buffer.add_string b v;
- Buffer.add_string b "\r\n");
+ Buffer.add_string b k;
+ Buffer.add_string b ": ";
+ Buffer.add_string b v;
+ Buffer.add_string b "\r\n");
Buffer.add_string b "\r\n";
Buffer.contents b
| `Network_connect_timeout_error -> 599
| `Code code -> code
+ (* Defined for status codes in RFC7230 *)
+ let body_allowed t =
+ match to_int t with 204 | 304 -> false | code -> code < 100 || code >= 200
+
let reason_phrase_of_code : int -> string = function
| 100 -> "Continue"
| 101 -> "Switching Protocols"
val to_string : t -> string
val to_int : t -> int
val of_int : int -> t
+
+ val body_allowed : t -> bool
+ (** [body_allowed status] returns whether a response with [status] allows a
+ payload body to be present per RFC7230. A [1xx], [204] or [304] response
+ is always terminated by the first empty line after the header fields, and
+ so carries neither a body nor any framing header.
+
+ https://www.rfc-editor.org/rfc/rfc7230#section-3.3 *)
+
val reason_phrase_of_code : int -> string
val pp : Format.formatter -> t -> unit
end
example below) are not affected by [clean_dup]. For example,
{v
- transfer-encoding: gzip
- host: afirsthost.com
- connection: keep-alive
- host: anhost.com, anotherhost.com
- transfer-encoding: chunked
+ transfer-encoding: gzip
+ host: afirsthost.com
+ connection: keep-alive
+ host: anhost.com, anotherhost.com
+ transfer-encoding: chunked
v}
becomes
{v
- transfer-encoding: gzip, chunked
- connection: keep-alive
- host: anhost.com, anotherhost.com
+ transfer-encoding: gzip, chunked
+ connection: keep-alive
+ host: anhost.com, anotherhost.com
v}
Finally, following
let valid_meth () =
[ `POST; `PUT; `PATCH ]
|> List.map (fun meth ->
- Request.make ~meth "p" |> Request.requires_content_length)
+ Request.make ~meth "p" |> Request.requires_content_length)
|> List.for_all Fun.id
|> aeb "requires_content_length m = true, where m is `POST, `PUT or `PATCH"
true
let invalid_meth () =
[ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ]
|> List.map (fun meth ->
- Request.make ~meth "p" |> Request.requires_content_length)
+ Request.make ~meth "p" |> Request.requires_content_length)
|> List.for_all not
|> aeb
{| requires_content_length m = false, where m is `GET; `HEAD;`DELETE;`OPTIONS;`TRACE; `CONNECT;`Other "h" |}
let some_x () =
[ (`POST, "0"); (`PUT, "233"); (`PATCH, "012345") ]
|> List.map (fun (meth, len) ->
- match
- Request.make ~meth
- ~headers:(Header.of_list [ ("Content-Length", len) ])
- "p"
- |> Request.content_length
- with
- | Some x -> int_of_string len = x
- | None -> false)
+ match
+ Request.make ~meth
+ ~headers:(Header.of_list [ ("Content-Length", len) ])
+ "p"
+ |> Request.content_length
+ with
+ | Some x -> int_of_string len = x
+ | None -> false)
|> List.for_all Fun.id
|> aeb "content_length t = Some x" true
in
let none () =
[ (`POST, "-1"); (`PUT, "-233"); (`PATCH, "abc") ]
|> List.map (fun (meth, len) ->
- match
- Request.make ~meth
- ~headers:(Header.of_list [ ("Content-Length", len) ])
- "p"
- |> Request.content_length
- with
- | Some _ -> false
- | None -> true)
+ match
+ Request.make ~meth
+ ~headers:(Header.of_list [ ("Content-Length", len) ])
+ "p"
+ |> Request.content_length
+ with
+ | Some _ -> false
+ | None -> true)
|> List.for_all Fun.id
|> aeb "content_length t = None" true
in
let method_ () =
[ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ]
|> List.map (fun meth ->
- match Request.make ~meth "p" |> Request.content_length with
- | Some _ -> false
- | None -> true)
+ match Request.make ~meth "p" |> Request.content_length with
+ | Some _ -> false
+ | None -> true)
|> List.for_all Fun.id
|> aeb "content_length t = None" true
in
( "content_length",
[ ("OK", `Quick, ok_status); ("`No_content", `Quick, no_content_status) ] )
+let body_allowed_tests =
+ let case (status, expected) =
+ ( Status.to_string status,
+ `Quick,
+ fun () ->
+ Status.body_allowed status
+ |> aeb ("body_allowed " ^ Status.to_string status) expected )
+ in
+ ( "body_allowed",
+ List.map case
+ [
+ (`Continue, false);
+ (`Switching_protocols, false);
+ (`Processing, false);
+ (`Checkpoint, false);
+ (`No_content, false);
+ (`Not_modified, false);
+ (`Code 199, false);
+ (`OK, true);
+ (`Created, true);
+ (`Found, true);
+ (`Bad_request, true);
+ (`Internal_server_error, true);
+ (`Code 250, true);
+ ] )
+
let () =
Alcotest.run "test_response"
- [ requires_content_length_tests; content_length_tests ]
+ [ requires_content_length_tests; content_length_tests; body_allowed_tests ]
projects / ocaml-cohttp.git / commitdiff